Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue24/ntserv/Services.pas

Pascal/Delphi Source File | 1997-07-04 | 15.0 KB | 522 lines

unit Services;

interface

{ If you activate this define the startup for service 2c will add a delay of   }
{ 45 seconds to DoServiceStartup and 30 seconds to DoServiceClose. It also     }
{ causes NeedExtnededElapseTime to return True if the current state is         }
{ SERVICE_START_PENDING or SERVICE_STOP_PENDING. This is to test the auto      }
{ update of the SCM status                                                     }

{.$DEFINE TESTLENGTHYOPERATIONS}

uses Windows, Messages, SysUtils, Classes, SvcClass, WinSvcX, Logging;

type
  TNTServiceControllerDemo = class(TNTServiceController)
  private
    FCriticalSection: TRTLCriticalSection;
    FFileCopyDetails: TStrings;
  public
    constructor Create; override;
    destructor Destroy; override;
  end;

type
  TService2a = class(TNTService)
  private
    FBeepDelay: Integer;
  protected
    function AcceptPause: Boolean; override;
    procedure DoServiceProcessing; override;
    procedure ProcessParms(Parms: TStrings); override;
  public
    class function ServiceDisplayName: Shortstring; override;
    class function ServiceName: Shortstring; override;
  end;

type
  TService2b = class(TNTService)
  private
    FFileList: TStrings;
    FFileExtensions: TStrings;
    FMonitorDirectory: string;
    FDriveChangeHandle: THandle;
    procedure AddToLog(const Text: string);
  protected
    function AcceptPause: Boolean; override;
    procedure DoServiceProcessing; override;
    procedure DoHandlerNotification; override;
    procedure ProcessParms(Parms: TStrings); override;
  public
    constructor Create(Parms: TStrings; Controller: TNTServiceController); override;
    destructor Destroy; override;
    class function ServiceDisplayName: Shortstring; override;
    class function ServiceName: Shortstring; override;
  end;

const
  BufferSize = 32768;

type
  TService2c = class(TNTService)
  private
    FConnectEvent: THandle;
    FInBuffer: array[0..255] of char;
    FOutBuffer: array[0..BufferSize-1] of char;
    FOverlap: TOverlapped;
    FPendingIO: Boolean;
    FPipe: THandle;
    FSecurityDesc: TSecurityAttributes;
    FState: DWORD;
    FSuccess: Boolean;
    FWaitStatus: DWORD;
  protected
    procedure DoHandlerNotification; override;
    procedure DoServiceCloseDown; override;
    procedure DoServiceProcessing; override;
    procedure DoServiceStartup; override;
    function NeedExtnededElapseTime(Option: DWORD): Boolean; override;
  public
    class procedure DependentServices(List: TStrings); override;
    class function ServiceDisplayName: Shortstring; override;
    class function ServiceName: Shortstring; override;
  end;

implementation

function DirectoryExists(const DirName: string): Boolean;
var
  SRec: TSearchRec;

begin
  SRec.FindHandle := FindFirstFile(PChar(DirName + '\*.*'),SRec.FindData);
  Result := SRec.FindHandle <> INVALID_HANDLE_VALUE;
  if Result then
    FindClose(SRec);
end;

{==============================================================================}

constructor TNTServiceControllerDemo.Create;
begin
  InitializeCriticalSection(FCriticalSection);
  FFileCopyDetails := TStringList.Create;
  inherited Create;
end;

destructor TNTServiceControllerDemo.Destroy;
begin
  FFileCopyDetails.Free;
  DeleteCriticalSection(FCriticalSection);
  inherited Destroy;
end;

{==============================================================================}

procedure TService2a.DoServiceProcessing;
begin
  While not Terminated do
    begin
      case CurrentState of
        SERVICE_RUNNING:
          begin
            MessageBeep(0);
          end;
        SERVICE_PAUSE_PENDING:
          begin
            CurrentState := SERVICE_PAUSED;
          end;
        SERVICE_CONTINUE_PENDING:
          begin
            CurrentState := SERVICE_RUNNING;
          end;
      end;
      Sleep(FBeepDelay);
    end;
end;

function TService2a.AcceptPause: Boolean;
begin
  Result := True;
end;

procedure TService2a.ProcessParms(Parms: TStrings);
var
  Delay: Integer;

begin
  FBeepDelay := 2000;
  if Parms.Count > 0 then
    try
      Delay := StrToInt(Parms[Parms.Count - 1]);
      if Delay < 500 then
        FBeepDelay := 500
      else
        if Delay > 10000 then
          FBeepDelay := 10000
        else
          FBeepDelay := Delay;
    except
      { Nothing - accept default of1 second }
    end;
end;

class function TService2a.ServiceDisplayName: Shortstring;
begin
  Result := 'Demonstration service 2a';
end;

class function TService2a.ServiceName: Shortstring;
begin
  Result := 'DemoService2a';
end;

{==============================================================================}

procedure ReadFileNames(const Directory,Mask: string; FileList: TStrings; RemoveExtension: Boolean);
var
  Status: Integer;
  SearchRec: TSearchRec;
  WildCard: string;
  I: Integer;
  S: string;

begin
  if Mask = '' then
    WildCard := '*.*'
  else
    WildCard := Mask;
  Status := FindFirst(Directory+'\'+WildCard,faAnyFile,SearchRec);
  try
    while Status = 0 do
      begin
        if (SearchRec.Attr and $1F = 0) then
          FileList.Add(SearchRec.Name);
        Status := FindNext(SearchRec);
      end; { While }
  finally
    FindClose(SearchRec);
  end;
  if RemoveExtension then
    for I := 0 to FileList.Count - 1 do
      begin
        S := FileList[I];
        System.Delete(S,Pos('.',S),4);
        FileList[I] := S;
      end;
end;

{==============================================================================}

constructor TService2b.Create(Parms: TStrings; Controller: TNTServiceController);
begin
  FFileExtensions := TStringList.Create;
  FFileExtensions.Add('*.*');
  FFileList := TStringList.Create;
  FMonitorDirectory := 'C:\TEMPX';
  if not DirectoryExists(FMonitorDirectory) then
    CreateDirectory(PChar(FMonitorDirectory),nil);
  CreateDirectory(PChar(FMonitorDirectory+'\SVBACKUP'),nil);
  inherited Create(Parms,Controller);
end;

destructor TService2b.Destroy;
begin
  FFileExtensions.Free;
  FFileList.Free;
  inherited Destroy;
end;

function TService2b.AcceptPause: Boolean;
begin
  Result := True;
end;

procedure TService2b.AddToLog(const Text: string);
begin
  EnterCriticalSection(TNTServiceControllerDemo(Controller).FCriticalSection);
  try
    TNTServiceControllerDemo(Controller).FFileCopyDetails.Add(Text);
  finally
    LeaveCriticalSection(TNTServiceControllerDemo(Controller).FCriticalSection);
  end;
end;

procedure TService2b.DoHandlerNotification;
begin
  inherited DoHandlerNotification;
  PostThreadMessage(ThreadId,WM_USER,0,0);
end;

procedure TService2b.DoServiceProcessing;
var
  WaitStatus: Integer;
  I: Integer;
  FSource,FDest: string;
  PutTimeOut: Boolean;
  Msg: TMsg;

  procedure CloseDirectoryNotification;
  begin
    FindCloseChangeNotification(FDriveChangeHandle);
    FDriveChangeHandle := 0;
  end;

  procedure SetupDirectoryNotification;
  begin
    FDriveChangeHandle := FindFirstChangeNotification(PChar(FMonitorDirectory),False,
                             FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or
                             FILE_NOTIFY_CHANGE_SIZE or FILE_NOTIFY_CHANGE_LAST_WRITE);
  end;

begin
  While not Terminated do
    begin
      case CurrentState of
        SERVICE_RUNNING:
          begin
            if FDriveChangeHandle = 0 then
              SetupDirectoryNotification;
            WaitStatus := MsgWaitForMultipleObjects(1,FDriveChangeHandle,False,Infinite,QS_POSTMESSAGE);
            case WaitStatus of
              WAIT_OBJECT_0: { FindFirstChangeNotification has been fired }
                begin
                  PutTimeOut := False;
                  FFileList.Clear;
                  ReadFileNames(FMonitorDirectory,FFileExtensions[0],FFileList,False);
                  for I := 0 to FFileList.Count - 1 do
                    begin
                      FSource := FMonitorDirectory+'\'+FFileList[I];
                      if GetFileAttributes(PChar(FSource)) and FILE_ATTRIBUTE_ARCHIVE <> 0 then
                        begin
                          if not PutTimeOut then
                            begin
                              AddToLog(Format('Directory %s was modified at %s',[FMonitorDirectory,FormatDateTime('hh:nn:ss dd/mm/yy',Now)]));
                              PutTimeOut := True;
                            end;
                          AddToLog(Format(' File %s was copied.',[FFileList[I]]));
                          FDest := FMonitorDirectory+'\SVBACKUP\'+FFileList[I];
                          CopyFile(PChar(FSource),PChar(FDest),False);
                          SetFileAttributes(PChar(FSource),FILE_ATTRIBUTE_NORMAL);
                        end;
                    end;
                  if not Terminated then
                    FindNextChangeNotification(FDriveChangeHandle);
                end;
              WAIT_OBJECT_0 + 1: { A message was posted to the thread - just discard it }
                GetMessage(Msg,0,0,0);
            end;
          end;
        SERVICE_PAUSE_PENDING:
          begin
            if FDriveChangeHandle <> 0 then
              CloseDirectoryNotification;
            CurrentState := SERVICE_PAUSED;
          end;
        SERVICE_CONTINUE_PENDING:
          begin
            CurrentState := SERVICE_RUNNING;
          end
      else
        Sleep(1000);
      end;
    end;
end;

procedure TService2b.ProcessParms(Parms: TStrings);
begin
  if Parms.Count = 1 then
    FFileExtensions.Assign(Parms);
end;

class function TService2b.ServiceDisplayName: Shortstring;
begin
  Result := 'Demonstration service 2b';
end;

class function TService2b.ServiceName: Shortstring;
begin
  Result := 'DemoService2b';
end;

{==============================================================================}

const
  NumInstances = 1;
  ClientTimeOut = 2000;

const
  WAITING_FOR_CONNECT_COMPLETE = 0;
  WAITING_FOR_READ_COMPLETE    = 1;
  WAITING_FOR_WRITE_COMPLETE    = 2;

class procedure TService2c.DependentServices(List: TStrings);
begin
  List.Add(TService2b.ServiceName);
end;

procedure TService2c.DoHandlerNotification;
begin
  inherited DoHandlerNotification;
  PostThreadMessage(ThreadId,WM_USER,0,0);
end;

procedure TService2c.DoServiceCloseDown;
begin
  DisconnectNamedPipe(FPipe);
  CloseHandle(FPipe);
  CloseHandle(FConnectEvent);
  FreeMem(FSecurityDesc.lpSecurityDescriptor,SECURITY_DESCRIPTOR_MIN_LENGTH);
{$IFDEF TESTLENGTHYOPERATIONS}
  Sleep(30000);
{$ENDIF}
end;

procedure TService2c.DoServiceProcessing;
var
  cbBytes: DWORD;
  Command: string;
  Msg: TMsg;

  procedure BuildQueryData;
  var
    Stream: TStream;

  begin
    EnterCriticalSection(TNTServiceControllerDemo(Controller).FCriticalSection);
    try
      if TNTServiceControllerDemo(Controller).FFileCopyDetails.Count = 0 then
        StrPCopy(FOutBuffer,'There is no data currently')
      else
        begin
          Stream := TMemoryStream.Create;
          try
            TNTServiceControllerDemo(Controller).FFileCopyDetails.SaveToStream(Stream);
            Stream.Position := 0;
            Stream.ReadBuffer(FOutBuffer,Stream.Size);
          finally
            Stream.Free;
          end;
        end;
    finally
      LeaveCriticalSection(TNTServiceControllerDemo(Controller).FCriticalSection);
    end;
  end;

  procedure ResetQueryData;
  begin
    EnterCriticalSection(TNTServiceControllerDemo(Controller).FCriticalSection);
    try
      TNTServiceControllerDemo(Controller).FFileCopyDetails.Clear;
    finally
      LeaveCriticalSection(TNTServiceControllerDemo(Controller).FCriticalSection);
    end;
    StrPCopy(FOutBuffer,'Data was reset')
  end;

  procedure StartConnect(Disconnect: Boolean);
  begin
    if Disconnect then
      DisconnectNamedPipe(FPipe);
    ConnectNamedPipe(FPipe,@FOverlap);
    case GetLastError of
      ERROR_IO_PENDING:
          FState := WAITING_FOR_CONNECT_COMPLETE;
      ERROR_PIPE_CONNECTED:
        begin
          FState := WAITING_FOR_READ_COMPLETE;
          SetEvent(FConnectEvent);
        end;
    end;
  end;

begin
  StartConnect(False);
  While not Terminated do
    begin
      FWaitStatus := MsgWaitForMultipleObjects(1,FConnectEvent,False,Infinite,QS_POSTMESSAGE);
      case FWaitStatus of
        WAIT_OBJECT_0:
          case FState of
            WAITING_FOR_CONNECT_COMPLETE:
              begin
                ReadFile(FPipe,FInBuffer,Sizeof(FInBuffer),cbBytes,@FOverlap);
                if GetLastError = ERROR_IO_PENDING then
                  FState := WAITING_FOR_READ_COMPLETE
                else
                  StartConnect(True);
              end;
            WAITING_FOR_READ_COMPLETE:
              begin
                Command := StrPas(FInBuffer);
                if Command = 'RESET' then
                  ResetQueryData
                else
                  if Command = 'QUERY' then
                    BuildQueryData
                  else
                    StrPCopy(FOutBuffer,'Unknown command option!');
                WriteFile(FPipe,FOutBuffer,StrLen(FOutBuffer),cbBytes,@FOverlap);
                if GetLastError = ERROR_IO_PENDING then
                  FState := WAITING_FOR_WRITE_COMPLETE
                else
                  StartConnect(True);
              end;
            WAITING_FOR_WRITE_COMPLETE:
              begin
                StartConnect(True);
              end;
          end;
        WAIT_OBJECT_0 + 1: { A message was posted to the thread }
          GetMessage(Msg,0,0,0);
      end;
    end;
end;

procedure TService2c.DoServiceStartup;
begin
  With FSecurityDesc do
    begin
      nLength := Sizeof(FSecurityDesc);
      lpSecurityDescriptor := AllocMem(SECURITY_DESCRIPTOR_MIN_LENGTH);
      InitializeSecurityDescriptor(lpSecurityDescriptor,SECURITY_DESCRIPTOR_REVISION);
      SetSecurityDescriptorDacl(lpSecurityDescriptor,True,nil,False);
    end;
  FConnectEvent := CreateEvent(nil,True,True,nil);
  FOverlap.hEvent := FConnectEvent;
  FPipe := CreateNamedPipe('\\.\Pipe\Service2b',
                           PIPE_ACCESS_DUPLEX or FILE_FLAG_OVERLAPPED,
                           PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT,
                           1,
                           BufferSize,
                           BufferSize,
                           ClientTimeout,
                           @FSecurityDesc);
{$IFDEF TESTLENGTHYOPERATIONS}
  Sleep(45000);
{$ENDIF}
end;

function TService2c.NeedExtnededElapseTime(Option: DWORD): Boolean;
begin
{$IFDEF TESTLENGTHYOPERATIONS}
  Result := (Option = SERVICE_START_PENDING) or (Option = SERVICE_STOP_PENDING);
{$ELSE}
  Result := False;
{$ENDIF}
end;

class function TService2c.ServiceDisplayName: Shortstring;
begin
  Result := 'Demonstration service 2c';
end;

class function TService2c.ServiceName: Shortstring;
begin
  Result := 'DemoService2c';
end;

end.